home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / w_utils.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  13.0 KB  |  350 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         w_utils.c
  5. * RCS:          $Header: w_utils.c,v 1.5 91/03/24 18:49:22 mayer Exp $
  6. * Description:  Various X Functionality
  7. * Author:       Niels Mayer, HPLabs
  8. * Created:      Fri Sep 29 01:24:38 1989
  9. * Modified:     Thu Oct  3 21:23:14 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: w_utils.c,v 1.5 91/03/24 18:49:22 mayer Exp $";
  43.  
  44. #include <stdio.h>
  45. #include <Xm/Xm.h>
  46. #include <X11/cursorfont.h>    /* defines XC_crosshair */
  47. #include "winterp.h"
  48. #include "user_prefs.h"
  49. #include "xlisp/xlisp.h"
  50.  
  51.  
  52. /******************************************************************************
  53.  ** (GET_MOUSE_LOCATION)
  54.  ** 
  55.  ** [ NEW ]:  it returns a dotted pair ... (root_x . root_y)
  56.  **
  57.  ** Primitive written by Richard Hess, Consilium, uunet!cimshop!rhess.
  58.  ** Fixes applied by Niels Mayer...
  59.  ******************************************************************************/
  60. LVAL Wut_Prim_GET_MOUSE_LOCATION()
  61. {
  62.   extern Display* display;    /* global in winterp.c */
  63.   extern Window   root_win;    /* global in winterp.c */
  64.   LVAL            lval_result, lval_x, lval_y;
  65.   int             x_rtn, y_rtn;
  66.   Window          junk1, junk2;
  67.   int             junk3, junk4;
  68.   unsigned int    junk5;
  69.   
  70.   /* protect some pointers -- added by NPM */
  71.   xlstkcheck(3);
  72.   xlsave(lval_x);
  73.   xlsave(lval_y);
  74.   xlsave(lval_result);
  75.  
  76.   if (!XQueryPointer(display, root_win, &junk1, &junk2,
  77.              &x_rtn, &y_rtn, &junk3, &junk4, &junk5))
  78.     xlerror("XQueryPointer() failed...");
  79.   lval_x = cvfixnum(x_rtn);
  80.   lval_y = cvfixnum(y_rtn);
  81.   lval_result = cons(lval_x, lval_y);
  82.  
  83.   /* restore the stack */
  84.   xlpopn(3);
  85.  
  86.   return (lval_result);
  87. }
  88.  
  89.  
  90. #ifdef hpux /* make this HPUX-only since sleepms() not portable */
  91. /******************************************************************************
  92.  * (X_REFRESH_DISPLAY [<sleep>])
  93.  * A kludgy hack to work around the Motif bug with refreshing and displaying popup
  94.  * status dialogues before embarking on a long computation. Use this function to
  95.  * work around cases where (send <widget> :update_display) isn't doing the right
  96.  * thing.
  97.  *
  98.  * The optional FIXNUM argument <sleep> is the number of milliseconds of sleep 
  99.  * time after popping up a shell before further expose events are procesed.
  100.  * The latter set of expose events correspond to drawing the "insides" of a
  101.  * popup dialog, e.g., the text and pixmaps.
  102.  *
  103.  * Note that making <sleep> too small means that the expose events generated
  104.  * by popping up a shell will not have time to round trip to the X server and
  105.  * back to the Motif client (WINTERP).
  106.  *
  107.  * If <sleep> is ommitted, then the sleeptime defaults to 300 millisecods.
  108.  * This time was empirically determined to be ok for my applications, but
  109.  * may not work if your workstation, X server, or network is slower than mine...
  110.  * As I said, this is a hack to work around a motif bug.
  111. ******************************************************************************/
  112. LVAL Wut_Prim_X_REFRESH_DISPLAY()
  113. {
  114.   extern sleepms();        /* from utils.c */
  115.   extern Display* display;    /* global in winterp.c */
  116.   extern LVAL true;
  117.   int sleeptime;
  118.   XEvent event;
  119.  
  120.   /* get optional <sleep> arg */
  121.   if (moreargs())
  122.     sleeptime = (int) getfixnum(xlgafixnum());
  123.   else
  124.     sleeptime = 300;        /* default value for <sleep> */
  125.  
  126.   xllastarg();
  127.  
  128.   XSync(display, FALSE);
  129.   while (XCheckMaskEvent(display, ExposureMask, &event))
  130.     XtDispatchEvent(&event);
  131.  
  132.   sleepms(sleeptime);
  133.  
  134.   XSync(display, FALSE);
  135.   while (XCheckMaskEvent(display, ExposureMask, &event))
  136.     XtDispatchEvent(&event);
  137.  
  138.   return (true);
  139. }
  140. #endif                /* hpux */
  141.  
  142.  
  143. /******************************************************************************
  144.  * (X_ALLOC_COLOR <color>)
  145.  * where <color> is a string, either a colorname from /usr/lib/X11/rgb.txt
  146.  * or a hexadecimal color specification "#RRGGBB".
  147.  * it returns a Pixel-value for the color.
  148. ******************************************************************************/
  149. LVAL Wut_Prim_XAllocColor()
  150. {
  151.   extern Display* display;    /* global in winterp.c */
  152.   extern Screen*  screen;    /* global in winterp.c */
  153.   extern Colormap colormap;    /* global in winterp.c */
  154.   XColor        screenColor;
  155.   LVAL          str_color;
  156.  
  157.   str_color = xlgastring();
  158.   xllastarg();
  159.   
  160.   if (!XParseColor(display, colormap, (String) getstring(str_color), &screenColor))
  161.     xlerror("XParseColor() couldn't parse color specification.", str_color);
  162.   if (!XAllocColor(display, colormap, &screenColor))
  163.     xlerror("XAllocColor() couldn't allocate specified color.", str_color);
  164.   return (cv_pixel(screenColor.pixel));
  165. }
  166.  
  167.  
  168. /******************************************************************************
  169.  * (X_STORE_COLOR <pixel> <color>)    [nicer would be (send <pixel> :store <color>)]
  170.  * where <color> is a string, either a colorname from /usr/lib/X11/rgb.txt
  171.  * or a hexadecimal color specification "#RRGGBB".
  172.  * it returns a Pixel-value for the color.
  173. ******************************************************************************/
  174. LVAL Wut_Prim_X_STORE_COLOR()
  175. {
  176.   extern Display* display;    /* global in winterp.c */
  177.   extern Screen*  screen;    /* global in winterp.c */
  178.   extern Colormap colormap;    /* global in winterp.c */
  179.   XColor        screenColor;
  180.   LVAL          str_color;
  181.   LVAL        lval_pixel;
  182.  
  183.   lval_pixel = xlga_pixel();
  184.   str_color = xlgastring();
  185.   xllastarg();
  186.   
  187.   screenColor.pixel = get_pixel(lval_pixel);
  188.   if (!XParseColor(display, colormap, (String) getstring(str_color), &screenColor))
  189.     xlerror("XParseColor() couldn't parse color specification.", str_color);
  190.   if (!XStoreColor(display, colormap, &screenColor))
  191.     xlerror("XStoreColor() couldn't allocate specified color.", str_color);
  192.   return (lval_pixel);
  193. }
  194.  
  195.  
  196. /******************************************************************************
  197.  * (X_ALLOC_N_COLOR_CELLS_NO_PLANES <num-cells>)
  198.  * returns an array of <num-cells> <pixel-objects> see Oliver Jones, p. 278
  199. ******************************************************************************/
  200. LVAL Wut_Prim_X_ALLOC_N_COLOR_CELLS_NO_PLANES()
  201. {
  202.   extern Display* display;    /* global in winterp.c */
  203.   extern Colormap colormap;    /* global in winterp.c */
  204.   Pixel*        pixels;
  205.   int        i, num_cells;
  206.   LVAL        result;
  207.  
  208.   num_cells = getfixnum(xlgafixnum());
  209.   xllastarg();
  210.   if (num_cells <= 0)
  211.     return (NIL);
  212.   
  213.   pixels = (Pixel*) XtMalloc((unsigned) (num_cells * sizeof(Pixel)));
  214.   XAllocColorCells(display, colormap, FALSE, NULL, 0, pixels, num_cells);
  215.  
  216.   xlsave1(result);
  217.   result = newvector(num_cells);
  218.   for (i = 0; i < num_cells; i++)
  219.     setelement(result, i, cv_pixel(pixels[i]));
  220.   xlpop();
  221.   XtFree(pixels);
  222.   return (result);
  223. }
  224.  
  225.  
  226. /******************************************************************************
  227.  * (GET_MOUSED_WIDGET)
  228.  * evaluating this function will change the cursor to a crossbar, indicating
  229.  * that the user is to 'click' the mouse to designate an object on the screen.
  230.  * If the user clicks on a visual item within WINTERP, this fucntion will
  231.  * return the WIDGETOBJ associated with the visual item. 
  232.  ******************************************************************************/
  233. LVAL Wut_UserClick_To_WidgetObj()
  234. {
  235.   extern Display* display;    /* global in winterp.c */
  236.   extern Window   root_win;    /* global in winterp.c */
  237.   extern LVAL     Wcls_WidgetID_To_WIDGETOBJ();    /* from w_classes.c */
  238.   extern XmGadget _XmInputInGadget(); /* in Xm/GadetUtils.c extern'd in XmP.h */
  239.   Cursor      cursor = XCreateFontCursor(display, XC_crosshair);
  240.   Window          parent_win, cur_win, child_win;
  241.   int             win_x, win_y;
  242.   Widget          widget_id, gadget_id;
  243.   XEvent      event;
  244.   Bool            xtc_ok;
  245.   
  246.   xllastarg();
  247.  
  248.   if (GrabSuccess != XGrabPointer(display, root_win, 0, ButtonPressMask|ButtonReleaseMask,
  249.                   GrabModeAsync, GrabModeAsync, None, cursor,
  250. #ifdef WINTERP_MOTIF_11
  251.                   XtLastTimestampProcessed(display)
  252. #else
  253.                   CurrentTime
  254. #endif                /* WINTERP_MOTIF_11 */
  255.                   ))
  256.     xlfail("GET_MOUSED_WIDGET -- couldn't grab pointer (XGrabPointer() failed).");
  257.   
  258.   XWindowEvent(display, root_win, ButtonPressMask, &event); /* remove the buttonpress from the queue*/
  259.   XWindowEvent(display, root_win, ButtonReleaseMask, &event); /* get the buttonrelease event */
  260.   XUngrabPointer(display,
  261. #ifdef WINTERP_MOTIF_11
  262.          XtLastTimestampProcessed(display)
  263. #else
  264.          CurrentTime
  265. #endif                /* WINTERP_MOTIF_11 */
  266.          );
  267.   XFlush(display);
  268.  
  269.   if (!event.xbutton.subwindow)
  270.     xlfail("GET_MOUSED_WIDGET aborted -- you clicked on the root window.");
  271.  
  272.   parent_win = event.xbutton.window; /* ASSERT event.xbutton.window == root_win, due to using XWindowEvent(root_win) */
  273.   win_x      = event.xbutton.x;
  274.   win_y      = event.xbutton.y;
  275.   cur_win    = event.xbutton.subwindow;
  276.   while ((xtc_ok = XTranslateCoordinates(display,
  277.                      parent_win, cur_win,
  278.                      win_x, win_y, /* give the x,y coords of event in parent_w */
  279.                      &win_x, &win_y, /* return the x,y coords relative to cur_win */
  280.                      &child_win)) /* returns child window of cur_win if that contains coords, else nil */
  281.      && child_win) {
  282. #ifdef DEBUG_WINTERP_1
  283.     fprintf(stderr, "parent_win=%lx, cur_win=%lx, child_win=%lx\n", parent_win, cur_win, child_win);
  284. #endif
  285.     parent_win = cur_win;
  286.     cur_win    = child_win;
  287.   }
  288.  
  289. #ifdef DEBUG_WINTERP_1
  290.   fprintf(stderr, "    Smallest window containing userclick is %lx\n", cur_win);
  291. #endif
  292.  
  293.   if (!xtc_ok)
  294.     xlfail("Bug in GET_MOUSED_WIDGET -- XTranslateCoordinates() failed.");
  295.  
  296.   if (!(widget_id = XtWindowToWidget(display, cur_win)))
  297.     xlfail("GET_MOUSED_WIDGET -- Couldn't find widget associated with window.\n    (Is the selected widget/window inside a different application?).\n");
  298.  
  299.   /* if the widget is a composite it may be managing a gadget -- attempt to retrieve it by looking up x,y coords in manager */
  300.   if (XtIsComposite(widget_id) &&
  301.       (gadget_id = (Widget) _XmInputInGadget(widget_id, win_x, win_y)))
  302.     return (Wcls_WidgetID_To_WIDGETOBJ(gadget_id)); /* then return the WIDGETOBJ assoc'd with gadget */
  303.   else
  304.     return (Wcls_WidgetID_To_WIDGETOBJ(widget_id)); /* otherwise, we return the WIDGETOBJ assoc'd with smallest window */
  305. }
  306.  
  307.  
  308. /******************************************************************************
  309.  * (load <fname> [:verbose] [:print])
  310.  *
  311.  * This function overrides xlisp/xlsys.c:xload(). All it does is check
  312.  * <fname> for '/' or '.' as the first character. If those don't exist, then
  313.  * the value of X resource "lispLibDir" is prepended and used as the filename.
  314.  * Note that "lispLibDir" should be the path to an existing directory with
  315.  * a trailing '/', e.g. "/usr/local/winterp/lisp-lib/"
  316.  ******************************************************************************/
  317. LVAL Wut_Prim_LOAD()
  318. {
  319.   extern LVAL k_verbose,k_print,true;
  320.   extern int xlgetkeyarg();    /* from xlisp/xlsubr.c */
  321.   extern char temptext[];    /* from winterp.c */
  322.   unsigned char *name;
  323.   int vflag,pflag;
  324.   LVAL arg;
  325.  
  326.   /* get the file name */
  327.   name = getstring(xlgetfname());
  328.  
  329.   /* get the :verbose flag */
  330.   if (xlgetkeyarg(k_verbose,&arg))
  331.     vflag = (arg != NIL);
  332.   else
  333.     vflag = TRUE;
  334.  
  335.   /* get the :print flag */
  336.   if (xlgetkeyarg(k_print,&arg))
  337.     pflag = (arg != NIL);
  338.   else
  339.     pflag = FALSE;
  340.  
  341.   /* load the file */
  342.   if ((name[0] != '/') && (name[0] != '.')) {
  343.     strcpy(temptext, user_prefs.lisp_lib_dir); /* prepend Xdefault 'lispLibDir', assume it has trailing '/' */
  344.     strcat(temptext, name);
  345.     return (xlload(temptext, vflag, pflag) ? true : NIL);
  346.   }
  347.   else
  348.     return (xlload(name, vflag, pflag) ? true : NIL);
  349. }
  350.